%*********************************************************************
%*********************************************************************
%                     THE STANDARD LISP COMPILER
%********************************************************************;
%********************************************************************;


COMMENT machine dependent parts are in a separate file;

COMMENT these include the macros described below and, in addition,
	an auxiliary function !&MKFUNC which is required to pass
	functional arguments (input as FUNCTION <func>) to the
	loader. In most cases, !&MKFUNC may be defined as MKQUOTE;


COMMENT general functions used in this compiler;

SYMBOLIC PROCEDURE EQCAR(U,V);
   NOT ATOM U AND CAR U EQ V;

SYMBOLIC PROCEDURE LPRIE U;
   <<PRINT("******" . U); ERROR(99,NIL)>>;

SYMBOLIC PROCEDURE MKQUOTE U;
   LIST('QUOTE,U);

SYMBOLIC PROCEDURE REVERSIP U;
   BEGIN SCALAR X,Y;
	WHILE U DO <<X := CDR U; Y := RPLACD(U,Y); U := X>>;
	RETURN Y
   END;

SYMBOLIC PROCEDURE RPLACW(A,B);
  RPLACA(RPLACD(A,CDR B),CAR B);

COMMENT the following two functions are used by the CONS open
	coding. They should be defined in the interpreter if
	possible. They should only be compiled without a COMPFN
	for CONS;

SYMBOLIC PROCEDURE NCONS U; U . NIL;

SYMBOLIC PROCEDURE XCONS(U,V); V . U;


COMMENT Registers used:
1-MAXNARGS	used for args of link. result returned in reg 1;

COMMENT Macros used in this compiler;

COMMENT The following macros must NOT change regs 1-MAXNARGS:

!*ALLOC nw      	allocate new stack frame of nw words
!*DEALLOC nw		deallocate above frame
!*ENTRY	name type noargs   entry point to function name of type type
			   with noargs args
!*FREERSTR alst		unbind free variables in alst
!*JUMP adr  		unconditional jump
!*JUMPNIL adr 		jump on register 1 NIL
!*JUMPT adr 		jump on register 1 not NIL
!*JUMPE adr exp 	jump on register 1 equal to exp
!*JUMPN adr exp 	jump on register 1 not equal to exp
!*LBL adr		define label
!*LAMBIND regs alst	bind free lambda vars in alst currently in regs
!*PROGBIND alst		bind free prog vars in alst
!*RETURN		return to previously saved return address
!*STORE reg floc	store contents of reg (or NIL) in floc

COMMENT the following macro must only change specific register being
	loaded:

!*LOAD reg exp		load exp into reg;

COMMENT the following macros do not protect regs 1-MAXNARGS:

!*LINK fn nargs		link to fn with nargs args
!*LINKL fn nargs loc	load loc in reg 1, link to fn with nargs args
!*LINKR fn nargs nw	link to fn with nargs args and return
			removing frame of nw words;


COMMENT variable types are: 

  LOCAL		allocated on stack and known only locally
  GLOBAL	accessed via cell (GLOBAL name) known to
	        loader at load time
  FLUID		accessed via cell (FLUID name)
		known to loader. This cell is rebound by LAMBIND/
		PROGBIND if variable used in lambda/prog list
		and restored by FREERSTR;


COMMENT global flags used in this compiler:

!*MODULE	indicates block compilation (a future extension of
		this compiler)
!*NOLINKL	if ON inhibits use of !*LINKL macro
!*NOLINKR 	if ON inhibits use of !*LINKR macro
!*ORD		if ON forces left-to-right argument evaluation
!*PLAP		if ON causes LAP output to be printed
!*R2I		if ON causes recursion removal where possible
!*SAVEDEF	if ON causes old (uncompiled) definition to remain
		and saves compiled macros with indicator COMPEXP;

GLOBAL '(!*MODULE !*NOLINKL !*NOLINKR !*ORD !*PLAP !*R2I !*SAVEDEF);

COMMENT global variables used:

MAXNARGS	number of arguments in true registers;

GLOBAL '(MAXNARGS);


COMMENT fluid variables used:

ALSTS	alist of fluid parameters
FLAGG	used in COMTST, and in FIXUP2
FREELST list of free variables with bindings
GOLIST	storage map for jump labels
IREGS	initial register contents
CODELIST  code being built
CONDTAIL simulated stack of position in the tail of a COND
LLNGTH	cell whose CAR is length of frame
NAME	name of function being currently compiled
NARG	number of arguments in function
REGS	known current contents of registers as an alist with elements 
	of form (<reg> . <contents>)
RETN	label for RETURN jump
LBLIST	list of label words
JMPLIST	list of locations in CODELIST of transfers
SLST	association list for stores which have not yet been used
STLST	list of active stores in function
STOMAP	storage map for variables
SWITCH	boolean expression value flag - keeps track of NULLs;

FLUID '(ALSTS FLAGG NAME GOLIST IREGS CODELIST CONDTAIL
	 LLNGTH NARG REGS RETN LBLIST JMPLIST SLST STLST STOMAP 
	 SWITCH REGS1 IREGS1 FREELST);


SYMBOLIC PROCEDURE COMPILE X;
   BEGIN SCALAR EXP,NAME;
  	WHILE X DO
	 <<NAME := CAR X;
	   EXP := GETD NAME;
	   IF NULL EXP THEN LPRIM LIST(NAME,'UNDEFINED)
	    ELSE COMPD(NAME,CAR EXP,CDR EXP);
	   X := CDR X>>
   END;

SYMBOLIC PROCEDURE COMPD(NAME,TYPE,EXP);
   BEGIN SCALAR CTYPE;
      IF TYPE EQ 'EXPR THEN CTYPE := 'SUBR
       ELSE IF TYPE EQ 'FEXPR THEN CTYPE := 'FSUBR
       ELSE <<LPRIM LIST("UNCOMPILABLE FUNCTION TYPE",TYPE);
	      RETURN NIL>>;
      IF NOT ATOM EXP 
	THEN IF !*MODULE THEN MODCMP(NAME,TYPE,EXP)
	 ELSE IF DFPRINT!*
	  THEN APPLY(DFPRINT!*,
		     LIST LIST(IF TYPE EQ 'EXPR THEN 'DE ELSE 'DF,
				NAME,CADR EXP,CADDR EXP))
	 ELSE BEGIN SCALAR X;
		X := LIST('!*ENTRY,NAME,CTYPE,LENGTH CADR EXP) .
			 !&COMPROC(EXP,NAME);
		IF !*PLAP THEN FOR EACH Y IN X DO PRINT Y;
		IF !*SAVEDEF THEN PUT(NAME,'COMPEXP,TYPE . X)
		 ELSE <<REMD NAME; LAP X>>
	      END;
      RETURN NAME
   END;

SYMBOLIC PROCEDURE !&COMPROC(EXP,NAME);
   %compiles a function body, returning the generated LAP;
  BEGIN SCALAR CODELIST,FLAGG,IREGS,IREGS1,JMPLIST,LBLIST,LLNGTH,
		REGS,REGS1,ALSTS,RETN,SLST,STLST,STOMAP,CONDTAIL;
		SCALAR REGS1,IREGS1,FREELST;
	   INTEGER NARG;
	LLNGTH := LIST 0;
	NARG := 0;
	RETN := !&GENLBL();
	STOMAP := '((NIL  0));
	CODELIST := LIST ('!*ALLOC . LLNGTH);
	EXP := !&PA1(EXP,NIL);
	FOR EACH Z IN CADR EXP DO
	   <<!&FRAME Z;
	     NARG := NARG+1;
	     IF NOT NONLOCAL Z
	       THEN IREGS := NCONC(IREGS,LIST LIST(NARG,Z));
	     REGS := NCONC(REGS,LIST LIST(NARG,Z))>>;
	IF NULL REGS THEN REGS := LIST(1 . NIL);
	ALSTS := !&FREEBIND(CADR EXP,T);
	!&COMVAL(CADDR EXP,0);
	!&FREERSTR(ALSTS,0);
	RETURN !&FIXUPS()
   END;

SYMBOLIC PROCEDURE NONLOCAL X;
 IF FLUIDP X THEN 'FLUID
  ELSE IF GLOBALP X THEN 'GLOBAL
  ELSE NIL;

FLUID '(VARS);

SYMBOLIC PROCEDURE !&PA1(U,VARS);
 BEGIN SCALAR X;
  RETURN
   IF ATOM U THEN IF CONSTANTP U OR U MEMQ '(NIL T)
		    THEN MKQUOTE U
		   ELSE IF U MEMBER VARS THEN U
		   ELSE IF GLOBALP U OR FLUIDP U THEN U
		   ELSE <<MKNONLOCAL U; U>>
    ELSE IF NOT ATOM CAR U THEN !&PA1(CAR U,VARS) . !&PALIS(CDR U,VARS)
    ELSE IF (X := GET(CAR U,'MACRO)) AND NOT GET(CAR U,'COMPFN)
     THEN !&PA1(APPLY(X,LIST U),VARS)
    ELSE IF CAR U EQ 'NOT THEN !&PA1('NULL . CDR U,VARS)
    ELSE IF CAR U EQ 'COND
     THEN 'COND . 
	   FOR EACH Z IN CDR U
		COLLECT LIST(!&PA1(CAR Z,VARS),!&PA1(CADR Z,VARS))
    ELSE IF CAR U MEMBER '(GO QUOTE) THEN U
    ELSE IF CAR U EQ 'LAMBDA
     THEN 'LAMBDA . CADR U . !&PALIS(CDDR U,APPEND(CADR U,VARS))
    ELSE IF CAR U EQ 'FUNCTION THEN IF ATOM CADR U THEN MKQUOTE CADR U
		ELSE MKQUOTE COMPD(!&MKNAM NAME,'EXPR,CADR U)
    ELSE IF X := GET(CAR U,'PA1FN) THEN APPLY(X,LIST(U,VARS))
    ELSE IF CAR U EQ 'PROG
     THEN 'PROG . CADR U . !&PAPROG(CDDR U,APPEND(CADR U,VARS))
    ELSE IF (X := GETD CAR U) AND CAR X MEMQ '(FEXPR FSUBR)
	   AND NOT GET(CAR U,'COMPFN)
     THEN <<!&PALIS(CDR U,NIL);   %to check for fluid vars;
	    LIST(CAR U,MKQUOTE CDR U)>>
    ELSE CAR U . !&PALIS(CDR U,VARS)
 END;

SYMBOLIC PROCEDURE !&PALIS(U,VARS);
   FOR EACH X IN U COLLECT !&PA1(X,VARS);

SYMBOLIC PROCEDURE !&PAPROG(U,VARS);
   FOR EACH X IN U COLLECT IF ATOM X THEN X ELSE !&PA1(X,VARS);

SYMBOLIC PROCEDURE MKNONLOCAL U;
   %make an undeclared non-local variable FLUID;
   <<LPRIM LIST(U,"declared fluid"); FLUID LIST U; LIST('FLUID,U)>>;

SYMBOLIC PROCEDURE !&MKNAM U;
   %generates unique name for auxiliary function in U;
   COMPRESS APPEND(EXPLODE U,EXPLODE GENSYM());

UNFLUID '(VARS);

SYMBOLIC PROCEDURE !&COMVAL(EXP,STATUS);
   %computes code for value of EXP;
   IF !&ANYREG(EXP,NIL) THEN IF STATUS>1 THEN NIL
	    		ELSE !&LREG1(EXP,STATUS)
	   ELSE !&COMVAL1(EXP,STOMAP,STATUS);

SYMBOLIC PROCEDURE !&COMVAL1(EXP,STOMAP,STATUS);
   BEGIN SCALAR X;
      IF ATOM EXP THEN IF STATUS<2 THEN !&LREG1(EXP,STATUS) ELSE NIL
       ELSE IF NOT ATOM CAR EXP
        THEN IF CAAR EXP EQ 'LAMBDA 
		THEN !&COMPLY(CAR EXP,CDR EXP,STATUS)
	      ELSE !&COMAPPLY(LIST('APPLY,CAR EXP,!&PALIST CDR EXP),
				   STATUS)
       ELSE IF X := GET(CAR EXP,'COMPFN) THEN APPLY(X,LIST(EXP,STATUS))
       ELSE IF ATSOC(CAR EXP,STOMAP)
	THEN !&COMAPPLY(LIST('APPLY,CAR EXP,!&PALIST CDR EXP),STATUS)
       ELSE IF !*R2I AND CAR EXP EQ NAME AND STATUS=0 AND NULL FREELST
	THEN !&COMREC(EXP,STATUS)
       ELSE !&CALL(CAR EXP,!&COMLIS CDR EXP,STATUS);
      RETURN NIL
   END;

SYMBOLIC PROCEDURE !&ANYREG(U,V);
   %determines if U can be loaded in any register;
   %!*ORD = T means force correct order, unless safe;
   NOT ATOM U AND CAR U EQ 'QUOTE
      OR ((IF ATOM U
	     THEN NOT NONLOCAL U AND ATSOC(U,STOMAP)
			      OR !&ANYREGL V
	   ELSE GET(CAR U,'ANYREG) AND !&ANYREG(CADR U,NIL))
	AND (NULL !*ORD OR !&ANYREGL V));

SYMBOLIC PROCEDURE !&ANYREGL U;
   NULL U OR !&ANYREG(CAR U,NIL) AND !&ANYREGL CDR U;

SYMBOLIC PROCEDURE !&CALL(FN,ARGS,STATUS);
   %ARGS is reversed list of compiled arguments of FN;
   BEGIN INTEGER ARGNO;
	ARGNO := LENGTH ARGS;
	!&LOADARGS(ARGS,STATUS);
	IF NOT !*NOLINKL AND CAAR CODELIST EQ '!*LOAD 
		AND CADAR CODELIST=1 
		AND NUMBERP CADDAR CODELIST 
		AND CADDAR CODELIST<=MAXNARGS
	  THEN <<!&ATTACH('!*LINKL . FN . ARGNO . CDDAR CODELIST);
		 !&MOVEUP CDR CODELIST>>
	 ELSE !&ATTACH LIST('!*LINK,FN,ARGNO);
	REGS := LIST (1 . NIL)
   END;

SYMBOLIC PROCEDURE !&COMLIS EXP;
   %returns reversed list of compiled arguments;
   BEGIN SCALAR ACUSED,Y;
	WHILE EXP DO
	  <<IF !&ANYREG(CAR EXP,CDR EXP) THEN Y := CAR EXP . Y
	     ELSE <<IF ACUSED THEN !&STORE1();
		    !&COMVAL1(CAR EXP,STOMAP,1);
		    ACUSED := GENSYM();
		    REGS := (1 . ACUSED . CDAR REGS) . CDR REGS;
		    Y:=ACUSED . Y>>;
	   EXP := CDR EXP>>;
	RETURN Y
   END;

SYMBOLIC PROCEDURE !&STORE1();
   %Marks contents of register 1 for storage;
   BEGIN SCALAR X;
	X := CADAR REGS;
	IF NULL X OR EQCAR(X,'QUOTE) THEN RETURN NIL
	 ELSE IF NOT ATSOC(X,STOMAP) THEN !&FRAME X;
	!&STORE(X,1)
   END;

SYMBOLIC PROCEDURE !&COMPLY(FN,ARGS,STATUS);
   BEGIN SCALAR ALSTS,VARS; INTEGER N,I;
	VARS := CADR FN;
	ARGS := !&COMLIS ARGS;
	N := LENGTH ARGS;
	IF N>MAXNARGS THEN LPRIE LIST("TOO MANY LAMBDA ARGS IN ",NAME);
	!&LOADARGS(ARGS,1);
	ARGS:=!&REMVARL VARS; % The stores that were protected;
	I:=1;
	FOR EACH V IN VARS DO <<!&FRAME V;
			        REGS:=!&REPASC(I,V,REGS);
			        I:=I+1>>;
	ALSTS := !&FREEBIND(VARS,T);  %Old fluid values saved;
	I:=1;
	FOR EACH V IN VARS DO
	 <<IF NOT NONLOCAL V THEN !&STORE(V,I);
	   I:=I+1>>;
	!&COMVAL(CADDR FN,STATUS);
	!&FREERSTR(ALSTS,STATUS);
	% Should now REMVAR names again, ? BEFORE OR AFTER ? ;
	!&RSTVARL(VARS,ARGS)
   END;

SYMBOLIC PROCEDURE !&COMREC(EXP,STATUS);
   BEGIN SCALAR X,Z;
	!&LOADARGS(!&COMLIS CDR EXP,STATUS);
	Z := CODELIST;
	WHILE CDDR Z DO Z := CDR Z;
	IF CAAR Z EQ '!*LBL THEN X := CDAR Z
	 ELSE <<X := !&GENLBL();
		RPLACD(Z,LIST(('!*LBL . X),CADR Z))>>;
	!&ATTJMP X
   END;

SYMBOLIC PROCEDURE !&LOADARGS(ARGS,STATUS);
   BEGIN INTEGER N;
	N := LENGTH ARGS;
	IF N>MAXNARGS THEN LPRIE LIST("TOO MANY ARGUMENTS IN",NAME);
	IF STATUS>0 THEN !&CLRREGS();
 	WHILE ARGS DO
	  <<!&LREG(N,CAR ARGS,CDR ARGS,STATUS);
		   N := N-1; ARGS := CDR ARGS>>;
  END;

SYMBOLIC PROCEDURE !&LOCATE X;
   BEGIN SCALAR Y,VTYPE;
	IF EQCAR(X,'QUOTE) THEN RETURN LIST X
	 ELSE IF Y := !&RASSOC(X,REGS)
	  THEN RETURN LIST LIST('!*REG,CAR Y)
	 ELSE IF NOT ATOM X THEN RETURN LIST(CAR X . !&LOCATE CADR X)
	 ELSE IF (VTYPE := NONLOCAL X) THEN RETURN LIST LIST(VTYPE,X);
	WHILE Y := ATSOC(X,SLST) DO SLST := DELETE(Y,SLST);
	RETURN IF Y := ATSOC(X,STOMAP) THEN CDR Y
		ELSE LIST MKNONLOCAL X
   END;

SYMBOLIC PROCEDURE !&LREG(REG,U,V,STATUS);
   BEGIN SCALAR X,Y;
	IF (X := ASSOC(REG,REGS)) AND U MEMBER CDR X THEN RETURN NIL
	 ELSE IF (Y := ASSOC(REG,IREGS))
		AND (STATUS>0 OR !&MEMLIS(CADR Y,V))
	  THEN <<!&STORE(CADR Y,REG); IREGS := DELETE(Y,IREGS)>>;
	!&ATTACH ('!*LOAD . REG . !&LOCATE U);
	REGS := !&REPASC(REG,U,REGS)
   END;

SYMBOLIC PROCEDURE !&LREG1(X,STATUS);
   !&LREG(1,X,NIL,STATUS);

SYMBOLIC PROCEDURE !&PALIST U;
   'LIST . U;


COMMENT Functions for Handling Non-local Variables;

SYMBOLIC PROCEDURE !&FREEBIND(VARS,LAMBP);
   %bind FLUID variables in lambda or prog lists;
   %LAMBP is true for LAMBDA, false for PROG;
   BEGIN SCALAR FALST,FREGS,X,Y; INTEGER I;
      I := 1;
      FOR EACH X IN VARS DO
	<<IF FLUIDP X
	    THEN <<FALST := (X . !&GETFFRM X) . FALST;
		   FREGS := I . FREGS>>
           ELSE IF GLOBALP X 
	    THEN LPRIE LIST("CANNOT BIND GLOBAL ",X);
	  I := I+1>>;
      IF NULL FALST THEN RETURN NIL;
      IF LAMBP THEN !&ATTACH LIST('!*LAMBIND,FREGS,FALST)
       ELSE !&ATTACH LIST('!*PROGBIND,FALST);
      RETURN FALST
   END;

SYMBOLIC PROCEDURE !&FREERSTR(ALSTS,STATUS);
   %restores FLUID variables;
   IF ALSTS THEN !&ATTACH LIST('!*FREERSTR,ALSTS);

SYMBOLIC PROCEDURE !&ATTACH U;
   CODELIST := U . CODELIST;

SYMBOLIC PROCEDURE !&STORE(U,REG);
   %marks expression U in register REG for storage;
   BEGIN SCALAR X;
	X := '!*STORE . REG . !&GETFRM U;
	STLST := X . STLST;
	!&ATTACH X;
	IF NULL CONDTAIL AND (X := ATSOC(U,SLST))
	  THEN <<STLST := !&DELEQ(CADR X,STLST);
	         SLST  := !&DELEQ(X,SLST);
		 RPLACA(CADR X,'!*NOOP)>>;
	IF ATOM U THEN SLST := (U . CODELIST) . SLST
   END;


COMMENT Functions for general tests;

SYMBOLIC PROCEDURE !&COMTST(EXP,LABL);
   %compiles boolean expression EXP.
   %If EXP has the same value as SWITCH then branch to LABL,
   %otherwise fall through;
   %REGS/IREGS are active registers for fall through,
   %REGS1/IREGS1 for branch;
   BEGIN SCALAR X;
	WHILE EQCAR(EXP,'NULL) DO
	  <<SWITCH := NOT SWITCH; EXP := CADR EXP>>;
	IF NOT ATOM EXP AND ATOM CAR EXP
		AND (X := GET(CAR EXP,'COMTST))
	    THEN APPLY(X,LIST(EXP,LABL))
	 ELSE <<IF EXP = '(QUOTE T)
	  THEN IF SWITCH THEN !&ATTJMP LABL
		ELSE FLAGG := T
	   ELSE <<!&COMVAL(EXP,1);
	        !&ATTACH LIST(IF SWITCH THEN '!*JUMPT ELSE '!*JUMPNIL,
			      CAR LABL);
		!&ADDJMP CODELIST>>;
	REGS1 := REGS; IREGS1 :=IREGS>>;
	IF EQCAR(CAR CODELIST,'!*JUMPT)
	  THEN REGS := (1 . '(QUOTE NIL) . CDAR REGS) . CDR REGS
	 ELSE IF EQCAR(CAR CODELIST,'!*JUMPNIL)
	  THEN REGS1 := (1 . '(QUOTE NIL) . CDAR REGS1) . CDR REGS1
   END;

COMMENT Specific Function Open Coding;

SYMBOLIC PROCEDURE !&COMANDOR(EXP,STATUS);
   BEGIN SCALAR FN,LABL,IREGSL,REGSL;
      FN := CAR EXP EQ 'AND;
      LABL := !&GENLBL();
      IF STATUS>1 THEN <<!&TSTANDOR(EXP,LABL); 
			 REGS := !&RMERGE2(REGS,REGS1)>>
       ELSE BEGIN
	IF STATUS>0 THEN !&CLRREGS();
	EXP := CDR EXP;
	WHILE EXP DO
	  <<!&COMVAL(CAR EXP,IF CDR EXP THEN 1 ELSE STATUS);
		%to allow for recursion on last entry;
	   IREGSL := IREGS . IREGSL; REGSL := REGS . REGSL;
	    IF CDR EXP THEN <<!&ATTACH LIST(IF FN THEN '!*JUMPNIL
					 ELSE '!*JUMPT,CAR LABL);
			      !&ADDJMP CODELIST>>;
	    EXP := CDR EXP>>;
      IREGS := !&RMERGE IREGSL;
      REGS := !&RMERGE REGSL;
	END;
      !&ATTLBL LABL
   END;

SYMBOLIC PROCEDURE !&TSTANDOR(EXP,LABL);
   BEGIN SCALAR FLG,FN,LAB2,REGSL,REGS1L,TAILP;
	FLG := SWITCH;
	SWITCH := NIL;
	FN := CAR EXP EQ 'AND;
	EXP := CDR EXP;
	LAB2 := !&GENLBL();
	!&CLRREGS();
	WHILE EXP DO
	 <<SWITCH := NIL;
	   IF NULL CDR EXP AND FLG EQ FN
	     THEN <<IF FN THEN SWITCH := T;
		    !&COMTST(CAR EXP,LABL);
		    REGSL := REGS . REGSL;
		    REGS1L := REGS1 . REGS1L>>
	    ELSE <<IF NOT FN THEN SWITCH := T;
		   IF FLG EQ FN
		     THEN <<!&COMTST(CAR EXP,LAB2);
			    REGSL := REGS1 . REGSL;
			    REGS1L := REGS . REGS1L>>
		    ELSE <<!&COMTST(CAR EXP,LABL);
			    REGSL := REGS . REGSL;
			    REGS1L := REGS1 . REGS1L>>>>;
	   IF NULL TAILP
	     THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>;
	   EXP := CDR EXP>>;
	!&ATTLBL LAB2;
	REGS := IF FN THEN CAR REGSL ELSE !&RMERGE REGSL;
	REGS1 := IF NULL FN THEN CAR REGS1L ELSE !&RMERGE REGS1L;
	IF TAILP THEN CONDTAIL := CDR CONDTAIL;
	SWITCH := FLG
   END;

PUT('AND,'COMPFN,'!&COMANDOR);

PUT('OR,'COMPFN,'!&COMANDOR);

SYMBOLIC PROCEDURE !&COMCOND(EXP,STATUS);
   %compiles conditional expressions;
   %registers REGS and IREGS are set for dropping through,
   %REGS1 and IREGS1 are set for a branch;
   BEGIN SCALAR GOCHN,IREGS1,REGS1,FLAGG,SWITCH,LAB1,LAB2,
		REGSL,IREGSL,TAILP;
	EXP := CDR EXP;
	LAB1 := !&GENLBL();
	GOCHN := T;
	IF STATUS>0 THEN !&CLRREGS();
	FOR EACH X IN EXP DO
	 <<LAB2 := !&GENLBL();
	   SWITCH := NIL;
	   !&COMTST(CAR X,LAB2);
	   %update CONDTAIL;
	   IF NULL TAILP
	     THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>;
	   !&COMVAL(CADR X,STATUS);   % Branch code;
	  %test if need jump to LAB1;
	   IF NOT EQCAR(CAR CODELIST,'!*JUMP)
	     THEN <<GOCHN := NIL; !&ATTJMP LAB1>>;
	   IREGSL := IREGS . IREGSL;
	   REGSL := REGS . REGSL;
	   REGS := REGS1;  %restore register status for next iteration;
	   IREGS := IREGS1;
	   !&ATTLBL LAB2>>;
	IF NULL FLAGG AND STATUS<2
	  THEN <<!&LREG1('(QUOTE NIL),STATUS);
		 IREGSL := IREGS . IREGSL;
		 REGSL := REGS . REGSL>>;
		%missing ELSE clause;
	IF NULL GOCHN THEN <<IREGS := !&RMERGE(IREGS . IREGSL);
			     REGS := !&RMERGE(REGS . REGSL)>>;
	!&ATTLBL LAB1;
	IF TAILP THEN CONDTAIL := CDR CONDTAIL
   END;

SYMBOLIC PROCEDURE !&RMERGE U;
   IF NULL U THEN NIL ELSE !&RMERGE1(CAR U,CDR U);

SYMBOLIC PROCEDURE !&RMERGE1(U,V);
   IF NULL V THEN U
    ELSE !&RMERGE1(!&RMERGE2(U,CAR V),CDR V);

SYMBOLIC PROCEDURE !&RMERGE2(U,V);
   IF NULL U OR NULL V THEN NIL
    ELSE (LAMBDA X;
	IF X THEN (CAAR U . XN(CDAR U,CDR X))
			 . !&RMERGE2(CDR U,DELETE(X,V))
	 ELSE !&RMERGE2(CDR U,V))
      ASSOC(CAAR U,V);

PUT('COND,'COMPFN,'!&COMCOND);

SYMBOLIC PROCEDURE !&COMCONS(EXP,STATUS);
   IF NULL (EXP := CDR EXP) OR NULL CDR EXP OR CDDR EXP
     THEN LPRIE "MISMATCH OF ARGUMENTS"
    ELSE IF CADR EXP= '(QUOTE NIL)
     THEN !&CALL('NCONS,!&COMLIS LIST CAR EXP,STATUS)
    ELSE IF !&ANYREG(CADR EXP,NIL)
     THEN !&CALL('CONS,!&COMLIS EXP,STATUS)
    ELSE !&CALL('XCONS,REVERSIP !&COMLIS EXP,STATUS);

PUT('CONS,'COMPFN,'!&COMCONS);

SYMBOLIC PROCEDURE !&COMGO(EXP,STATUS);
   IF STATUS>2
     THEN <<!&ATTJMP !&GETLBL CADR EXP; SLST := NIL>>
    ELSE LPRIE "INVALID GO STATEMENT";

PUT('GO,'COMPFN,'!&COMGO);

SYMBOLIC PROCEDURE !&COMLIST(EXP,STATUS);
   %we only support explicit functions up to 5 registers here;
   BEGIN SCALAR M,N,FN;
	EXP := CDR EXP;
	M := MIN(MAXNARGS,5);
	N := LENGTH EXP;
	IF N=0 THEN !&LREG1('(QUOTE NIL),STATUS)
	 ELSE IF N>M THEN !&COMVAL(!&COMLIST2 EXP,STATUS)
	 ELSE !&CALL(IF N=1 THEN 'NCONS
		      ELSE IF N=2 THEN 'LIST2
		      ELSE IF N=3 THEN 'LIST3
		      ELSE IF N=4 THEN 'LIST4 ELSE 'LIST5,
		     !&COMLIS EXP,STATUS)
   END;

SYMBOLIC PROCEDURE LIST2(U,V); U . V . NIL;

SYMBOLIC PROCEDURE LIST3(U,V,W); U . V . W . NIL;

SYMBOLIC PROCEDURE LIST4(U,V,W,X); U . V . W . X . NIL;

SYMBOLIC PROCEDURE LIST5(U,V,W,X,Y); U . V . W . X . Y . NIL;

SYMBOLIC PROCEDURE !&COMLIST2 EXP;
   BEGIN SCALAR L1,N;
	N := MIN(MAXNARGS,5);
	WHILE N>0 DO
	   <<L1 := CAR EXP . L1; EXP := CDR EXP; N := N-1>>;
	RETURN LIST('NCONC,'LIST . REVERSIP L1,'LIST . EXP)
  END;

PUT('LIST,'COMPFN,'!&COMLIST);

COMMENT an alternative definition for COMLIST;

%SYMBOLIC PROCEDURE !&COMLIST(EXP,STATUS);
% Map to sequence of CONS's;
%   !&COMVAL(!&COMLIST1 CDR  EXP,STATUS);

%SYMBOLIC PROCEDURE !&COMLIST1 EXP;
%   IF NULL EXP THEN '(QUOTE NIL)  ;
%    ELSE LIST('CONS,CAR EXP,!&COMLIST1 CDR EXP);

SYMBOLIC PROCEDURE !&PAMAP(U,VARS);
   IF EQCAR(CADDR U,'FUNCTION)
     THEN (LAMBDA X; LIST(CAR U,!&PA1(CADR U,VARS),
		      MKQUOTE IF ATOM X THEN X ELSE !&PA1(X,VARS)))
	    CADR CADDR U
    ELSE CAR U . !&PALIS(CDR U,VARS);

PUT('MAP,'PA1FN,'!&PAMAP);

PUT('MAPC,'PA1FN,'!&PAMAP);

SYMBOLIC PROCEDURE !&MAP(EXP,STATUS);
   BEGIN SCALAR BODY,FN,LAB1,LAB2,SLST1,VAR,X;
	BODY := CADR EXP; FN := CADDR EXP;
      LAB1 := !&GENLBL(); LAB2 := !&GENLBL();
      !&CLRREGS();
      !&FRAME(VAR := GENSYM());
      !&COMVAL(BODY,1);
      REGS := LIST LIST(1,VAR);
      !&ATTLBL LAB1;
      !&ATTACH LIST('!*JUMPNIL,CAR LAB2);
      !&ADDJMP CODELIST;
      !&STORE(VAR,1);
      X := IF CAR EXP EQ 'MAP THEN VAR ELSE LIST('CAR,VAR);
      IF EQCAR(FN,'QUOTE) THEN FN := CADR FN;
      SLST1 := SLST;   %to allow for store in function body;
      !&COMVAL(LIST(FN,X),3);
      SLST := XN(SLST,SLST1);
      !&COMVAL(LIST('CDR,VAR),1);
      !&ATTJMP LAB1;
      !&ATTLBL LAB2;
      REGS := LIST LIST(1,MKQUOTE NIL);
   END;

SYMBOLIC PROCEDURE XN(U,V);
   IF NULL U THEN NIL
    ELSE IF CAR U MEMBER V THEN CAR U . XN(CDR U,DELETE(CAR U,V))
    ELSE XN(CDR U,V);

PUT('MAP,'COMPFN,'!&MAP);

PUT('MAPC,'COMPFN,'!&MAP);

SYMBOLIC PROCEDURE !&COMPROG(EXP,STATUS);
   %compiles program blocks;
    BEGIN SCALAR ALSTS,GOLIST,PG,PROGLIS,RETN; INTEGER I;
	PROGLIS := CADR EXP;
	EXP := CDDR EXP;
	RETN := !&GENLBL();
	PG := !&REMVARL PROGLIS;   %protect prog variables;
	FOR EACH X IN PROGLIS DO !&FRAME X;
	ALSTS := !&FREEBIND(PROGLIS,NIL);
	FOR EACH X IN PROGLIS DO
		IF NOT NONLOCAL X THEN !&STORE(X,NIL);
	FOR EACH X IN EXP DO
	    IF ATOM X THEN GOLIST := (X . !&GENLBL()) . GOLIST;
	WHILE EXP DO
	 <<IF ATOM CAR EXP
	        THEN <<!&CLRREGS();
		       !&ATTLBL !&GETLBL CAR EXP;
		        REGS:= LIST(1 . NIL)>>
		%since we do not know how we arrived here;
	     ELSE !&COMVAL(CAR EXP,IF STATUS>2 THEN 4 ELSE 3);
	   IF NULL CDR EXP AND STATUS<2
		AND (ATOM CAR EXP OR NOT CAAR EXP MEMBER '(GO RETURN))
	   THEN EXP := LIST '(RETURN (QUOTE NIL))
	    ELSE EXP := CDR EXP>>;
	!&ATTLBL RETN;
	IF CDR !&FINDLBL RETN THEN REGS := LIST(1 . NIL);
	!&FREERSTR(ALSTS,STATUS);
	!&RSTVARL(PROGLIS,PG)
   END;

PUT('PROG,'COMPFN,'!&COMPROG);

SYMBOLIC PROCEDURE !&REMVARL VARS;
   FOR EACH X IN VARS COLLECT !&REMVAR X;

SYMBOLIC PROCEDURE !&REMVAR X;
   %removes references to variable X from IREGS and REGS
   %and protects SLST;
   BEGIN
      FOR EACH Y IN IREGS DO
	 IF X EQ CADR Y THEN <<!&STORE(CADR Y,CAR Y);
				 IREGS := DELETE(Y,IREGS)>>;
      FOR EACH Y IN REGS DO
	 WHILE X MEMBER CDR Y DO RPLACD(Y,!&DELEQ(X,CDR Y));
      RETURN !&PROTECT X
   END;

SYMBOLIC PROCEDURE !&PROTECT U;
   BEGIN SCALAR X;
      IF (X := ATSOC(U,SLST)) THEN SLST := !&DELEQ(X,SLST);
      RETURN X
   END;

SYMBOLIC PROCEDURE !&RSTVARL(VARS,LST);
   WHILE VARS DO
      <<!&RSTVAR(CAR VARS,CAR LST); VARS := CDR VARS; LST := CDR LST>>;

SYMBOLIC PROCEDURE !&RSTVAR(VAR,VAL);
   BEGIN
      FOR EACH X IN IREGS DO
	IF VAR EQ CADR X THEN <<!&STORE(CADR X,CAR X);
				IREGS := DELETE(X,IREGS)>>;
      FOR EACH X IN REGS DO
	WHILE VAR MEMBER CDR X DO RPLACD(X,!&DELEQ(VAR,CDR X));
      !&CLRSTR VAR;
      !&UNPROTECT VAL
   END;

SYMBOLIC PROCEDURE !&CLRSTR VAR;
   %removes unneeded stores;
   BEGIN SCALAR X;
      IF CONDTAIL THEN RETURN NIL;
      X := ATSOC(VAR,SLST);
      IF NULL X THEN RETURN NIL;
      STLST := !&DELEQ(CADR X,STLST);
      SLST := !&DELEQ(X,SLST);
      RPLACA(CADR X,'!*NOOP)
   END;

SYMBOLIC PROCEDURE !&UNPROTECT VAL;
   %restores VAL to SLST;
   IF VAL THEN SLST := VAL . SLST;

SYMBOLIC PROCEDURE !&COMPROGN(EXP,STATUS);
   BEGIN
      EXP := CDR EXP;
      WHILE CDR EXP DO
	<<!&COMVAL(CAR EXP,IF STATUS<2 THEN 2 ELSE STATUS);
	  EXP := CDR EXP>>;
      !&COMVAL(CAR EXP,STATUS)
   END;

PUT('PROG2,'COMPFN,'!&COMPROGN);
PUT('PROGN,'COMPFN,'!&COMPROGN);

SYMBOLIC PROCEDURE !&COMRETURN(EXP,STATUS);
   <<IF STATUS<4 OR NOT !&ANYREG(CADR EXP,NIL)
     THEN !&LREG1(CAR !&COMLIS LIST CADR EXP,STATUS);
     !&ATTJMP RETN>>;

PUT('RETURN,'COMPFN,'!&COMRETURN);

SYMBOLIC PROCEDURE !&COMSETQ(EXP,STATUS);
   BEGIN SCALAR X;
      EXP := CDR EXP;
   IF STATUS>1 AND (NULL CADR EXP OR CADR EXP='(QUOTE NIL)) 
    THEN !&STORE2(CAR EXP,NIL)
    ELSE <<!&COMVAL(CADR EXP,1);
	   REGS := !&REMSETVAR(REGS,CAR EXP);
	   !&STORE2(CAR EXP,1);
	   IF X := !&RASSOC(CAR EXP,IREGS)
		THEN IREGS := DELETE(X,IREGS);
	   REGS := (1 . CAR EXP . CDAR REGS) . CDR REGS>>
   END;

SYMBOLIC PROCEDURE !&REMSETVAR(U,V);
   IF NULL U THEN NIL
    ELSE (CAAR U . !&REMS1(CDAR U,V)) . !&REMSETVAR(CDR U,V);

SYMBOLIC PROCEDURE !&REMS1(U,V);
   IF NULL U THEN NIL
    ELSE IF ATOM U
	 THEN IF U EQ V THEN !&REMS1(CDR U,V)
		 ELSE CAR U . !&REMS1(CDR U,V)
    ELSE IF CAR U EQ 'QUOTE OR NOT V MEMBER FLATTEN CAR U
     THEN CAR U . !&REMS1(CDR U,V)
    ELSE !&REMS1(CDR U,V);

SYMBOLIC PROCEDURE !&STORE2(U,V);
   BEGIN SCALAR VTYPE;
     IF VTYPE := NONLOCAL U
       THEN !&ATTACH LIST('!*STORE,V,LIST(VTYPE,U))
       ELSE IF NOT ATSOC(U,STOMAP)
	THEN !&ATTACH LIST('!*STORE,V,MKNONLOCAL U)
       ELSE !&STORE(U,V);
   END;

PUT('SETQ,'COMPFN,'!&COMSETQ);


COMMENT Specific Test Open Coding;

PUT('AND,'COMTST,'!&TSTANDOR);
PUT('OR,'COMTST,'!&TSTANDOR);

SYMBOLIC PROCEDURE !&CEQ(EXP,LABL);
   BEGIN SCALAR U,V,W;
	U := CADR EXP;
	V := CADDR EXP;
	IF U MEMBER CDAR REGS THEN W := !&CEQ1(V,U)
	 ELSE IF V MEMBER CDAR REGS THEN W := !&CEQ1(U,V)
	 ELSE IF !&ANYREG(V,NIL) THEN <<!&COMVAL(U,1);
				   W := !&LOCATE V>>
	 ELSE IF !&ANYREG(U,LIST V) THEN <<!&COMVAL(V,1);
					   W := !&LOCATE U>>
	 ELSE <<U := !&COMLIS CDR EXP; W := !&LOCATE CADR U>>;
	!&ATTACH ((IF SWITCH THEN '!*JUMPE ELSE '!*JUMPN)
		. CAR LABL . W);
	IREGS1 := IREGS; REGS1 := REGS;
	!&ADDJMP CODELIST
   END;

SYMBOLIC PROCEDURE !&CEQ1(U,V);
   IF !&ANYREG(U,LIST V) THEN !&LOCATE U 
    ELSE <<!&COMVAL(U,1); !&LOCATE V>>;

PUT('EQ,'COMTST,'!&CEQ);


COMMENT Support Functions;

SYMBOLIC PROCEDURE !&MEMLIS(U,V);
   V AND (!&MEMB(U,CAR V) OR !&MEMLIS(U,CDR V));

SYMBOLIC PROCEDURE !&MEMB(U,V);
   IF ATOM V THEN U EQ V ELSE !&MEMB(U,CADR V);

SYMBOLIC PROCEDURE !&RASSOC(U,V);
   IF NULL V THEN NIL
    ELSE IF U MEMBER CDAR V THEN CAR V
    ELSE !&RASSOC(U,CDR V);

SYMBOLIC PROCEDURE !&REPASC(REG,U,V);
   IF NULL V THEN LIST LIST(REG,U)
    ELSE IF REG=CAAR V THEN LIST(REG,U) . CDR V
    ELSE CAR V . !&REPASC(REG,U,CDR V);

SYMBOLIC PROCEDURE !&CLRREGS();
   %store deferred values in IREGS;
   WHILE IREGS DO <<!&STORE(CADAR IREGS,CAAR IREGS);
		    IREGS := CDR IREGS>>;

SYMBOLIC PROCEDURE !&GENLBL();
   BEGIN SCALAR L;
	L := GENSYM();
	LBLIST := LIST L . LBLIST; 
	RETURN LIST L;
   END;

SYMBOLIC PROCEDURE !&GETLBL LABL;
  BEGIN SCALAR X;
	X := ATSOC(LABL,GOLIST);
	IF NULL X THEN LPRIE LIST(LABL," - MISSING LABEL -");
	RETURN CDR X
   END;

SYMBOLIC PROCEDURE !&FINDLBL LBLST;
   ASSOC(CAR LBLST,LBLIST);

SYMBOLIC PROCEDURE !&RECHAIN(OLBL,NLBL);
% Fix OLBL to now point at NLBL;
   BEGIN SCALAR X,Y,USES;
	X := !&FINDLBL OLBL;
	Y := !&FINDLBL NLBL;
	RPLACA(OLBL,CAR NLBL); % FIX L VAR;
	USES:=CDR X; % OLD USES;
	RPLACD(X,NIL);
	RPLACD(Y,APPEND(USES,CDR Y));
	FOR EACH X IN USES DO RPLACA(CDR X,CAR NLBL)
   END;

SYMBOLIC PROCEDURE !&MOVEUP U;
   IF CAADR U EQ '!*JUMP 
	THEN <<JMPLIST:=!&DELEQ(CDR U,JMPLIST);
	       RPLACW(U,CDR U);
	       JMPLIST:=U . JMPLIST>>
   ELSE RPLACW(U,CDR U);

SYMBOLIC PROCEDURE !&ATTLBL LBL;
    IF CAAR CODELIST EQ '!*LBL THEN !&RECHAIN(LBL,CDAR CODELIST)
	ELSE !&ATTACH ('!*LBL . LBL);

SYMBOLIC PROCEDURE !&ATTJMP LBL;
   BEGIN
	IF CAAR CODELIST EQ '!*LBL THEN
	  <<!&RECHAIN(CDAR CODELIST,LBL);
	   CODELIST :=  CDR CODELIST>>;
	IF CAAR CODELIST EQ '!*JUMP THEN RETURN;
	!&ATTACH ('!*JUMP .  LBL);
	!&ADDJMP CODELIST
   END;

SYMBOLIC PROCEDURE !&ADDJMP CLIST;
   BEGIN SCALAR X;
	X := !&FINDLBL CDAR CLIST; RPLACD(X,CAR CLIST . CDR X);
	JMPLIST := CLIST . JMPLIST
   END;

SYMBOLIC PROCEDURE !&REMJMP CLIST;
   BEGIN SCALAR X;
	X := !&FINDLBL CDAR CLIST;
	RPLACD(X,!&DELEQ(CAR CLIST,CDR X));
	JMPLIST := !&DELEQ(CLIST,JMPLIST);
	!&MOVEUP CLIST;
   END;

SYMBOLIC PROCEDURE !&DELEQ(U,V);
   IF NULL V THEN NIL
    ELSE IF U EQ CAR V THEN CDR V
     ELSE CAR V . !&DELEQ(U,CDR V);


SYMBOLIC PROCEDURE !&FRAME U;
   % ALLOCATES SPACE FOR U IN FRAME;
   BEGIN SCALAR Z;
	STOMAP := LIST(U,Z := CADAR STOMAP+1) . STOMAP;
	IF Z>CAR LLNGTH THEN RPLACA(LLNGTH,Z)
   END;

SYMBOLIC PROCEDURE !&GETFRM U;
   (LAMBDA X;
	IF X THEN CDR X 
	 ELSE LPRIE LIST("COMPILER ERROR: LOST VAR",U))
    ATSOC(U,STOMAP);

SYMBOLIC PROCEDURE !&GETFFRM U;
   BEGIN SCALAR X;
      X := !&GETFRM U;
      FREELST := X . FREELST;
      RETURN X
   END;


COMMENT Post Code Generation Fixups;

SYMBOLIC PROCEDURE !&FIXUPS;
   BEGIN SCALAR FLAGG;
      FOR EACH J IN SLST
	 DO <<STLST := !&DELEQ(CADR J,STLST); RPLACA(CADR J,'!*NOOP)>>;
      !&FIXUP1();
      IF FLAGG THEN <<IF NOT !*NOLINKR
			     AND CAAR CODELIST EQ '!*LBL
			     AND CAADR CODELIST EQ '!*LINKR
			THEN RPLACA(CDR CODELIST,
				    LIST('!*LINK,CADADR CODELIST,
						CADR CDADR CODELIST));
			%removes unnecessary LINKR;
		      !&ATTACH('!*DEALLOC . LLNGTH);
		      !&ATTACH LIST '!*RETURN>>;
      RETURN !&FIXUP2()
   END;

SYMBOLIC PROCEDURE !&FIXUP1;
   BEGIN SCALAR EJMPS,EJMPS1,P,Q;
	IF NOT CAR CODELIST ='!*LBL . RETN THEN !&ATTLBL RETN;
	CODELIST := CDR CODELIST;
	IF NOT CAR CODELIST = '!*JUMP . RETN THEN !&ATTJMP RETN;
	%find any common chains of code;
	EJMPS := REVERSE JMPLIST;
	WHILE EJMPS DO
	   BEGIN
	      P := CAR EJMPS; EJMPS := CDR EJMPS;
	      IF CAAR P EQ '!*JUMP
     	      THEN <<EJMPS1 := EJMPS;
		      WHILE EJMPS1 DO
			IF CAR P=CAAR EJMPS1 AND CADR P=CADAR EJMPS1
			  THEN <<!&REMJMP P;
				 !&FIXCHN(P,CDAR EJMPS1);
			         EJMPS1 := NIL>>
		         ELSE EJMPS1 := CDR EJMPS1>>
	   END;
	%replace LINK by LINKR where appropriate;
	EJMPS := JMPLIST;
	IF NOT !*NOLINKR THEN WHILE EJMPS DO
	   BEGIN
	      P := CAR EJMPS; Q := CDR P; EJMPS := CDR EJMPS;
	      IF NOT CADAR P EQ CAR RETN THEN RETURN NIL
	       ELSE IF NOT CAAR P EQ '!*JUMP  OR NOT CAAR Q EQ '!*LINK
		THEN RETURN FLAGG := T;
 	      RPLACW(CAR Q,'!*LINKR . CADAR Q . CADDAR Q . LLNGTH);
		!&REMJMP P;
		END   ELSE FLAGG := T;
	    !&FIXFRM();
	   !&ATTLBL RETN
   END;

SYMBOLIC PROCEDURE !&FINDBLK(U,LBL);
   IF NULL CDR U THEN NIL
    ELSE IF CAADR U EQ '!*LBL AND CAADDR U MEMBER '(!*LINKR !*JUMP)
     THEN U
    ELSE IF GET(CAADR U,'NEGJMP) AND CADADR U EQ LBL THEN U
    ELSE !&FINDBLK(CDR U,LBL);

PUT('!*NOOP,'OPTFN,'!&MOVEUP);

PUT('!*LBL,'OPTFN,'!&LABOPT);

SYMBOLIC PROCEDURE !&LABOPT U;
  BEGIN SCALAR Z;
   IF CADAR U EQ CADADR U
	 THEN RETURN !&REMJMP CDR U  %(JUMPx lab) (LAB lab);
    ELSE IF CAADR U EQ '!*JUMP AND (Z := GET(CAADDR U,'NEGJMP))
     AND CADAR U EQ CADR CADDR U
     THEN RETURN <<Z := Z . CADADR U . CDDR CADDR U;
	    !&REMJMP CDR U;
	    !&REMJMP CDR U;
	    RPLACD(U,Z . CADR U . CDDR U);
	    !&ADDJMP CDR U;
	    T>>   %(JUMPx lab1) (JUMP lab2) (LAB lab1);
    ELSE RETURN NIL
   END;

SYMBOLIC PROCEDURE !&FIXUP2;
   %'peep-hole' optimization for various cases;
   BEGIN SCALAR LABS,TLABS,X,Y,Z;
	%local code fixes;
	Z := CODELIST;
	WHILE Z DO IF NOT (X := GET(CAAR Z,'OPTFN))
			OR NOT APPLY(X,LIST Z)
		     THEN Z := CDR Z;
	WHILE CODELIST DO
	   <<IF CAAR CODELIST EQ '!*LBL 
	  	THEN <<!&LABOPT CODELIST;
		 %since block transfers may cause new chains to emerge;
		IF CDR (Z := !&FINDLBL CDAR CODELIST)
		  THEN <<Y := CAR CODELIST . Y;
			IF NULL CDDR Z
			   AND CAADR Z MEMBER '(!*JUMP !*LINKR)
			   AND CAADR Y EQ '!*LOAD
			   AND !&NOLOADP(CDADR Y,
					 CDR ATSOC(CADR Z,JMPLIST))
	  		  THEN <<IF NOT !&NOLOADP(CDADR Y,CDR CODELIST)
		   		  THEN RPLACW(CDR CODELIST,CADR Y .
					CADR CODELIST . CDDR CODELIST);
				  RPLACW(CDR Y,CDDR Y)>>
		 ELSE <<IF NULL CDDR Z AND CAADR CODELIST EQ '!*JUMP
			AND GET(CAADR Z,'NEGJMP)
		  THEN LABS := (CADR Z . Y) . LABS;
		IF CAADR CODELIST MEMBER '(!*JUMP !*LINKR)
		 THEN TLABS := (CADAR Y . Y) . TLABS>>>>>>
		%case of (JUMPx lab) M1 ... Mn ... (LAB lab) M1 ... Mn
		%where Mi do not affect reg 1;
	      ELSE IF GET(CAAR CODELIST,'NEGJMP) 
			AND (Z := ATSOC(CAR CODELIST,LABS))
		THEN <<X := CAR CODELIST; CODELIST := CDR CODELIST;
			Z := CDDR Z;
			WHILE CAR Y=CAR Z AND (CAAR Y EQ '!*STORE
			   OR CAAR Y EQ '!*LOAD AND NOT(CADAR Y=1)) DO
				<<CODELIST := CAR Y . CODELIST;
				  RPLACW(Z,CADR Z . CDDR Z);
				  Y := CDR Y>>;
			CODELIST := X . CODELIST;
			Y:= X . Y>>
	      ELSE IF CAAR CODELIST EQ '!*JUMP
		 AND (Z := ATSOC(CADAR CODELIST,TLABS))
		AND (X := !&FINDBLK(CDR CODELIST,
				    IF CAAR Y EQ '!*LBL THEN CADAR Y
				     ELSE NIL))
		THEN BEGIN SCALAR W;
		IF NOT CAADR X EQ '!*LBL 
		  THEN <<IF NOT CAAR X EQ '!*LBL 
			   THEN X := CDR RPLACD(X,('!*LBL . !&GENLBL())
							 . CDR X);
			 W:= GET(CAADR X,'NEGJMP) . CADAR X . CDDADR X;
			 !&REMJMP CDR X;
			 RPLACD(X,W . CADR X . CDDR X);
			 !&ADDJMP CDR X>>
		 ELSE X := CDR X;
		W := NIL;
		REPEAT <<W := CAR Y . W; Y := CDR Y>> UNTIL Y EQ CDR Z;
		RPLACD(X,NCONC(W,CDR X));
		!&REMJMP CODELIST;
		TLABS := NIL;   %since code chains have changed;
		CODELIST := NIL . CAR Y . CODELIST;
		Y := CDR Y
	      END
	      ELSE Y := CAR CODELIST . Y;
	     CODELIST := CDR CODELIST>>;
	RETURN Y
   END;

SYMBOLIC PROCEDURE !&NOLOADP(ARGS,INSTRS);
    %determines if a LOAD is not necessary in instruction stream;
   ATOM CADR ARGS AND
    (CAAR INSTRS EQ '!*LOAD AND CDAR INSTRS=ARGS
     OR CAAR INSTRS EQ '!*STORE AND (CDAR INSTRS=ARGS 
		OR CADDAR INSTRS NEQ CADR ARGS
		   AND !&NOLOADP(ARGS,CDR INSTRS)));

SYMBOLIC PROCEDURE !&FIXCHN(U,V);
   BEGIN SCALAR X;
	WHILE CAR U=CAR V DO <<!&MOVEUP U; V := CDR V>>;
	X := !&GENLBL();
	IF CAAR V EQ '!*LBL THEN !&RECHAIN(X,CDAR V)
	 ELSE RPLACW(V,('!*LBL . X) . CAR V . CDR V);
	IF CAAR U EQ '!*LBL
	  THEN <<!&RECHAIN(CDAR U,X);!&MOVEUP U>>;
	IF  CAAR U EQ '!*JUMP THEN RETURN;
	RPLACW(U,('!*JUMP . X) . CAR U . CDR U);
	!&ADDJMP U
    END;

SYMBOLIC PROCEDURE !&FIXFRM;
   BEGIN SCALAR HOLES,LST,X,Y,Z; INTEGER N;
	IF NULL STLST THEN RETURN RPLACA(LLNGTH,0);
	N := 1;
	WHILE NOT(N>CAR LLNGTH) DO
	 <<Y:= NIL;
	  FOR EACH LST IN STLST DO
	   IF N = CADDR LST THEN Y := CDDR LST . Y;
	  FOR EACH LST IN FREELST DO
	   IF N=CAR LST THEN Y := LST . Y;
	  IF NULL Y THEN HOLES := N . HOLES ELSE Z := (N . Y) . Z;
	  N := N+1>>;
	Y := Z;
	IF CAAR Z<CAR LLNGTH THEN RPLACA(LLNGTH,CAAR Z);
	WHILE HOLES DO <<
		WHILE HOLES AND CAR HOLES>CAR LLNGTH
			DO HOLES := CDR HOLES;
	     IF HOLES
		THEN <<HOLES := REVERSIP HOLES;
			FOR EACH X IN CDAR Z DO RPLACA(X,CAR HOLES);
			RPLACA(LLNGTH,
				IF NULL CDR Z OR CAR HOLES >CAADR Z
				   THEN CAR HOLES
			 	 ELSE CAADR Z);
			HOLES := REVERSIP CDR HOLES;
			Z := CDR Z>>>>;
	%now see if we can map stack to registers;
	IF FREELST OR NULL !®P CODELIST OR CAR LLNGTH>MAXNARGS-NARG
	  THEN RETURN;
	N := IF NARG<3 THEN 3 ELSE NARG+1;
	FOR EACH X IN STLST DO
	   RPLACW(X,LIST('!*LOAD,CADDR X+N,
	     IF NULL CADR X THEN '(QUOTE NIL)
		ELSE LIST('!*REG,CADR X)));
	WHILE Y DO
	   <<FOR EACH X IN CDAR Y DO
		 ATOM CAR X AND RPLACA(X,LIST('!*REG,CAR X+N));
	     Y := CDR Y>>;
	RPLACA(LLNGTH,0)
   END;

SYMBOLIC PROCEDURE !®P U;
   %there is no test for LAMBIND/PROGBIND
   %since FREELST tested explicitly in FIXFRM;
   IF NULL CDR U THEN T
    ELSE IF FLAGP(CAADR U,'LINK)
	AND NOT(FLAGP!*!*(CADADR U,'TWOREG) OR CAR U =('!*JUMP . RETN))
      THEN NIL
    ELSE !®P CDR U;

SYMBOLIC PROCEDURE FLAGP!*!*(U,V);
   ATOM U AND NOT NUMBERP U AND FLAGP(U,V);

FLAG('(!*LINK !*LINKL !*LINKR),'LINK);

PUT('!*JUMPN,'NEGJMP,'!*JUMPE);
PUT('!*JUMPE,'NEGJMP,'!*JUMPN);
PUT('!*JUMPNIL,'NEGJMP,'!*JUMPT);
PUT('!*JUMPT,'NEGJMP,'!*JUMPNIL);